home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / BackCompatibility.tcl < prev    next >
Encoding:
Text File  |  2000-12-06  |  11.7 KB  |  440 lines
  1. # You should avoid calling any of these procs:
  2. # They are slower, and may be removed at some point in the future.
  3. # 
  4. # Some of these are currently called from Alpha's main menus.  This
  5. # will be changed in the future, so that this entire file can vanish.
  6.  
  7. # just wrappers around other procs
  8.  
  9. if {[info exists warningForObsoleteProcedures] && ($warningForObsoleteProcedures == 1)} {
  10.     # To help ensure Alpha(tk) doesn't need anything from here.
  11.     if {[askyesno "Some code requires [array names unknown_pending]; please\
  12.       try to remove that dependence on deprecated procedures.  Throw an error?"] == "yes"} {
  13.     error "Code required [array names unknown_pending]"
  14.     }
  15. }
  16.  
  17. proc realMenuName {name} {
  18.     global subMenuInfo
  19.     return [lindex $subMenuInfo($name) 1]
  20. }
  21. proc rebuildSimpleFilesetMenus {} {
  22.     global gfileSets
  23.     eval [menu::makeFlagMenu choose list currFileSet]
  24.     Menu -n hideFileset -m -p filesetMenu::hideOrShow [lsort [array names gfileSets]]
  25.     filesetUtilsMarksTicks
  26. }
  27.  
  28. proc killWindowStatus {} { closeAWindow }
  29. proc chooseWindowStatus {} { chooseAWindow }
  30.  
  31. proc sPromptChoices {msg def choices} {
  32.     uplevel 1 prompt::fromChoices [list $msg $def -list $choices]
  33. }
  34.  
  35. proc sPrompt {msg def} {
  36.     global useStatusBar
  37.     if {!$useStatusBar} {return [prompt $msg $def]}
  38.     if {[catch {statusPrompt "$msg ($def): "} ans]} {
  39.     error "cancel"
  40.     }
  41.     if {![string length $ans]} {return $def}
  42.     return $ans
  43. }
  44.  
  45. # This is superceded by more general completion/prompt routines which
  46. # do the same thing when told to use '-command winNames'.
  47. proc winComp {curr c} {
  48.     if {$c != "\t"} {return $c}
  49.     
  50.     set matches {}
  51.     foreach w [winNames] {
  52.     if {[string match "$curr*" $w]} {
  53.         lappend matches $w
  54.     }
  55.     }
  56.     if {![llength $matches]} {
  57.     error "No match"
  58.     } else {
  59.     return [string range [largestPrefix $matches] [string length $curr] end]
  60.     }
  61.     return ""
  62. }
  63.  
  64. namespace eval file {}
  65. namespace eval help {}
  66.  
  67. proc file::searchAndHyperise {args} { uplevel 1 win::searchAndHyperise $args }
  68. proc file::multiSearchAndHyperise {args} { uplevel 1 win::multiSearchAndHyperise $args }
  69. proc file::jumpToCode {args} { uplevel 1 win::jumpToCode $args }
  70.  
  71. proc file::hyperHelpFileOpen { name } {
  72.     help::openGeneral $name
  73. }
  74. proc file::hyperOpen {name} {
  75.     help::openHyper $name
  76. }
  77.  
  78. proc file::hyperHelpOpen { name } {
  79.     help::openGeneral $name
  80. }
  81. proc file::hyperExampleOpen {{f ""}} {
  82.     help::openExample $f
  83. }
  84.  
  85. proc openFolder {args} {
  86.     uplevel 1 file::showInFinder $args
  87. }
  88. proc pushMark {} {pushPosition}
  89. proc popMark {} {popPosition}
  90. proc pushPosition {args} {uplevel placeBookmark $args}
  91. proc popPosition {args} {uplevel returnToBookmark $args}
  92. proc absolutePath {filename} {file::absolutePath $filename}
  93. proc openFileQuietly {filename} {
  94.     edit -c -w $filename
  95. }
  96. proc searchInFile {filename searchString {indices 0}} {
  97.     file::searchFor $filename $searchString $indices
  98. }
  99.  
  100. proc readFile {fileName} {file::readAll $fileName}
  101. proc writeFile {filename {text {}} {overwrite 0}} {
  102.     file::writeAll $filename $text $overwrite
  103. }
  104. proc gotoFileLine {fname line {mesg {}}} {
  105.     file::gotoLine $fname $line $mesg
  106. }
  107.  
  108. proc buildSubMenu {args} {
  109.     eval menu::buildHierarchy $args
  110. }
  111.  
  112. proc listSubfolders {folder {depth 3}} {
  113.     file::hierarchy $folder $depth
  114. }
  115.  
  116. proc getIncludeFiles {} { optClickTB_List }
  117. proc editIncludeFile {item} { optClickTB_Pick $item}
  118. proc tryElseDump {name script} {
  119.     try::level \#0 $script -reporting log -while $name
  120. }
  121. proc text::genericIndent {} { ::indentLine }
  122.  
  123. proc revertTheseFiles {flist} {eval file::revertThese $flist}
  124.  
  125. proc file::commentTextBlock {args} { eval comment::TextBlock $args }
  126. proc commentLine  {args} { uplevel 1 comment::Line $args }
  127. proc uncommentLine  {args} { uplevel 1 comment::undoLine $args }
  128. proc commentBox  {args} { uplevel 1 comment::Box $args }
  129. proc uncommentBox  {args} { uplevel 1 comment::undoBox $args }
  130. proc commentCharacters {args} { uplevel 1 comment::Characters $args }
  131. proc commentGetRegion  {args} { uplevel 1 comment::GetRegion $args }
  132. proc commentSameStart  {args} { uplevel 1 comment::SameStart $args }
  133. proc commentTextBlock  {args} { uplevel 1 comment::TextBlock $args }
  134. proc commentGetFillLines {args} { uplevel 1 comment::GetFillLines $args }
  135. proc commentParagraph  {args} { uplevel 1 comment::Paragraph $args }
  136. proc uncommentParagraph {args} { uplevel 1 comment::undoParagraph $args }
  137. proc fillParagraph {args} {uplevel 1 paragraph::fill $args}
  138. proc fillOneParagraph {args} {uplevel 1 paragraph::fillOne $args}
  139. proc paraStart {args} {uplevel 1 paragraph::start $args}
  140. proc paraFinish {args} {uplevel 1 paragraph::finish $args}
  141. proc sentenceParagraph {args} {uplevel 1 paragraph::sentence $args}
  142. proc selectParagraph {args} {uplevel 1 paragraph::select $args}
  143. proc addArrDef {args} { uplevel 1 prefs::addArrayElement $args }
  144. proc removeArrDef {args} { uplevel 1 prefs::removeArrayElement $args }
  145. proc addDef {args} {uplevel 1 prefs::add $args}
  146. proc removeDef {args} {uplevel 1 prefs::remove $args}
  147. proc readDefs {args} {uplevel 1 prefs::_read $args}
  148. proc writeDefs {args} {uplevel 1 prefs::_write $args}
  149. proc addArr {args} { uplevel 1 prefs::addArray $args }
  150. proc removeArr {args} { uplevel 1 prefs::removeArray $args }
  151. proc saveModifiedVars {args} { uplevel 1 prefs::saveModified $args }
  152. proc alpha::readUserDefs {} {uplevel 1 prefs::readAll}
  153. proc alpha::readUserPrefs {} {uplevel 1 prefs::tclRead}
  154. proc addUserLine {args} { uplevel 1 prefs::tclAddLine $args}
  155. namespace eval mode {}
  156. proc mode::addUserLine {args} {uplevel 1 prefs::tclAddModeLine $args}
  157. proc getSavedSettings {} {prefs::listAllSaved}
  158.  
  159. proc upBrowse {} { browse::Up }
  160. proc downBrowse {} { browse::Down }
  161. proc gotoMatch {} { browse::Goto }
  162.  
  163. proc stripNameCount str { win::StripCount $str }
  164.  
  165. ########################################
  166. #                           #
  167. #    A few random lisp'ish functions.  #
  168. #                       #
  169. ########################################
  170.  
  171. proc car {l} {lindex $l 0}
  172. proc cadr {l} {lindex $l 1}
  173. proc caddr {l} {lindex $l 2}
  174. proc cadddr {l} {lindex $l 3}
  175. proc caddddr {l} {lindex $l 4}
  176. proc cdr {l} {lrange $l 1 end}
  177. proc cddr {l} {lrange $l 2 end}
  178.  
  179. proc mapcar args {return [eval map $args]}
  180.  
  181. proc map {func l} {
  182.     set out {}
  183.     foreach el $l {
  184.     lappend out [eval $func [list $el]]
  185.     }
  186.     return $out
  187. }
  188.  
  189. proc cons {e l} {concat [list $e] $l}
  190.  
  191. # ◊◊◊◊ Legacy TclAE Definitions ◊◊◊◊ #
  192.  
  193. ## 
  194.  # -------------------------------------------------------------------------
  195.  # 
  196.  # "aebuild::*" --
  197.  # 
  198.  #  Wrapper routines for tclAE::build::*. Don't call these in new code.
  199.  # 
  200.  # -------------------------------------------------------------------------
  201.  ##
  202.  
  203. namespace eval aebuild {}
  204.  
  205. proc aebuild::result {args} {
  206.     return [eval tclAE::build::resultData $args]
  207. }
  208.  
  209. proc aebuild::objectProperty {process property object} {
  210.     return [tclAE::build::objectProperty $process $property $object]
  211. }
  212.  
  213. proc aebuild::coercion {type value} {
  214.     return [tclAE::build::coercion $type $value]
  215. }
  216.  
  217. proc aebuild::list {l args} {
  218.     return [eval tclAE::build::List [list $l] $args]
  219. }
  220.  
  221. proc aebuild::hexd {value} {
  222.     return [tclAE::build::hexd $value]
  223. }
  224.  
  225. proc aebuild::bool {val} {
  226.     return [tclAE::build::bool $val]
  227. }
  228.  
  229. proc aebuild::TEXT {str} {
  230.     return [tclAE::build::TEXT $str]
  231. }
  232.  
  233. proc aebuild::alis {path} {
  234.     return [tclAE::build::alis $path]
  235. }
  236.  
  237. proc aebuild::fss {value} {
  238.     return [tclAE::build::fss $value]
  239. }
  240.  
  241. proc aebuild::name {name} {
  242.     return [tclAE::build::name $name]
  243. }
  244.  
  245. proc aebuild::filename {name} {
  246.     return [tclAE::build::filename $name]
  247. }
  248.  
  249. proc aebuild::winByName {name} {
  250.     return [tclAE::build::winByName $name]
  251. }
  252.  
  253. proc aebuild::winByPos {absPos} {
  254.     return [tclAE::build::winByPos $absPos]
  255. }
  256.  
  257. proc aebuild::lineRange {absPos1 absPos2} {
  258.     return [tclAE::build::lineRange $absPos1 $absPos2]
  259. }
  260.  
  261. proc aebuild::absPos {posName} {
  262.     return [tclAE::build::absPos $posName]
  263. }
  264.  
  265. proc aebuild::startupDisk {} {
  266.     return [tclAE::build::startupDisk]
  267. }
  268.  
  269. proc aebuild::userName {} {
  270.     return [tclAE::build::userName]
  271. }
  272.  
  273.  
  274. namespace eval aeparse {}
  275.  
  276. proc aeparse::event {chars args} {
  277.     return [eval tclAE::parse::event [list $chars] $args]
  278. }
  279.  
  280. proc aeparse::keywordValue {keyword record {typed 0}} {
  281.     if {$typed} {
  282.         return [tclAE::getKeyDesc $record $keyword]
  283.     } else {
  284.         return [tclAE::getKeyData $record $keyword]
  285.     }
  286. }
  287.  
  288.  
  289. namespace eval aecoerce {}
  290.  
  291. proc aecoerce::identity {value} {
  292.     return $value
  293. }
  294.  
  295. proc aecoerce::hexd:bool {value} {
  296.     binary scan $value c bool
  297.     
  298.     if {![info exists bool]
  299.     ||    ($bool != 0 && $bool != 1)} {
  300.         error::throwOSErr -1700
  301.     }
  302.     
  303.     return $bool
  304. }
  305.  
  306. proc aecoerce::hexd:TEXT {value} {
  307.     binary scan $value a* TEXT
  308.     return $TEXT
  309. }
  310.  
  311. proc aecoerce::hexd {value} {
  312.     error "I have no idea what this is supposed to do"
  313. }
  314.  
  315. proc aecoerce::null:TEXT {value} {
  316.     return [tclAE::coerce::null>hexd $value]
  317. }
  318.  
  319. proc aecoerce::hexd:alis {value} {
  320.     set resultDesc [tclAE::createDesc alis]
  321.     tclAE::coerce::TEXT>alis TEXT $value alis $resultDesc
  322.     set result [tclAE::print $resultDesc]
  323.     tclAE::disposeDesc $resultDesc
  324.     
  325.     return $result
  326. }
  327.  
  328. proc aecoerce::TEXT:alis {value} {
  329.     return [aecoerce::hexd:alis [binary format a* $value]]
  330. }
  331.  
  332. proc aecoerce::register {args} {
  333.     return [eval tclAE::installCoercionHandler $args]
  334. }
  335.  
  336. proc aecoerce::apply {AEDesc toType} {
  337.     set newDesc [tclAE::coerceDesc $AEDesc $toType]
  338.         set result [tclAE::getData $newDesc]
  339.         tclAE::disposeDesc $newDesc
  340.     
  341.     return $result
  342. }
  343.     
  344. proc aecoerce::deregister {hook {procname ""} args} {
  345.     error "There is no way to make \[aecoerce::deregister\] compatible with modern TclAE. \
  346.       The code must be changed to use \[tclAE::removeCoercionHandler\]"
  347. }
  348.  
  349. # I don't believe these are used anywhere, but put them here 
  350. # to avoid the 7.4b17 fiasco
  351.  
  352. namespace eval tclAE {}
  353. namespace eval tclAE::coerce {}
  354.  
  355. proc tclAE::coerce::null>TEXT {value} {
  356.     return ""
  357. }
  358.  
  359. ## 
  360.  # bool ::= bool(«00|01»)
  361.  ##
  362. proc tclAE::coerce::_hexd>bool {value} {
  363.     set value [tclAE::coerce::_long>hexd $value]
  364.     set bool [expr {"0x$value"}]
  365.     if {($bool != 0) && ($bool != 1)} {
  366.         set msg "Can't coerce «$value» from 'hexd' to 'bool'"
  367.         error $msg "" [list AECoerce -1700 $msg]
  368.     } 
  369.     return $bool
  370. }
  371.  
  372. proc tclAE::coerce::_****>hexd {value} {
  373.     set newval $value
  374.     if {[expr {[string length $newval] % 2}]} {
  375.         # left pad with zero to make even number of digits
  376.         set newval "0${newval}"
  377.     } 
  378.     if {![is::Hexadecimal $newval]} {
  379.         set msg "Non-hex-digit in «${value}»" 
  380.         error $msg "" [list AECoerce 6 $msg]
  381.     } else {
  382.         return ${newval}
  383.     }
  384. }
  385.  
  386. proc tclAE::coerce::_hexd>TEXT {value} {
  387.     # make sure input is really hexd
  388.     set value [tclAE::coerce::_****>hexd $value]
  389.  
  390.     set TEXT ""
  391.     set length [string length $value]
  392.     set i 0
  393.     while {$i < $length} {
  394.         append TEXT [uplevel 0 "set temp \\x[string range $value $i [incr i]]"]
  395.         incr i
  396.     }
  397.     return $TEXT
  398. }
  399.  
  400. proc tclAE::coerce::_long>hexd {value} {
  401.     set newval [format "%08X" $value]
  402.     return [tclAE::coerce::_****>hexd $newval]
  403. }
  404.  
  405. proc tclAE::coerce::_shor>hexd {value} {
  406.     set newval [format "%04X" $value]
  407.     return [tclAE::coerce::_****>hexd $newval]
  408. }
  409.  
  410. if {[info tclversion] < 8.0} {
  411.     proc tclAE::coerce::_TEXT>hexd {value} {
  412.             set length [string length $value]
  413.             set hexd ""
  414.             for {set i 0} {$i < $length} {incr i} {
  415.                     if {[set char [string index $value $i]] == "\x00"} {
  416.                             # scan doesn't work on \x00, so we handle it specially.
  417.                             append hexd "00"
  418.                     } else {
  419.                             scan $char "%c" char
  420.                             append hexd [format "%02X" $char]                
  421.                     } 
  422.             }    
  423.             
  424.             return $hexd
  425.     }    
  426. } else {
  427.     proc tclAE::coerce::_TEXT>hexd {value} {
  428.         binary scan $value H* hexd
  429.         return $hexd
  430.     }
  431. }
  432.  
  433.  
  434. # mtime doesn't understand hex notation,
  435. # so we force to decimal first
  436. proc tclAE::coerce::_hexd>ldt {hexd} {
  437.     return [join [mtime [tclAE::coerce::hexd>long $hexd] short]]
  438. }
  439.  
  440.